home *** CD-ROM | disk | FTP | other *** search
- unit NameHlp2U;
-
- {$ifdef Ver90} //Delphi 2
- {$define Delphi2}
- {$endif}
- {$ifdef Ver93} //BCB1
- {$define Delphi2}
- {$endif}
-
- interface
-
- uses
- {$ifdef Delphi2} //BCB1
- OLE2,
- {$endif}
- ShlObj, Windows, Classes, ComCtrls;
-
- {$ifdef Delphi2}
- type
- IShellFolder = class(IUnknown)
- function ParseDisplayName(hwndOwner: HWND;
- pbcReserved: Pointer; lpszDisplayName: POLESTR; var pchEaten: ULONG;
- var ppidl: PItemIDList; var dwAttributes: ULONG): HResult; virtual; stdcall; abstract;
- function EnumObjects(hwndOwner: HWND; grfFlags: DWORD;
- var EnumIDList: IEnumIDList): HResult; virtual; stdcall; abstract;
- function BindToObject(pidl: PItemIDList; pbcReserved: Pointer;
- const riid: TIID; var ppvOut: Pointer): HResult; virtual; stdcall; abstract;
- function BindToStorage(pidl: PItemIDList; pbcReserved: Pointer;
- riid: TIID; var ppvObj: Pointer): HResult; virtual; stdcall; abstract;
- function CompareIDs(lParam: LPARAM;
- pidl1, pidl2: PItemIDList): HResult; virtual; stdcall; abstract;
- function CreateViewObject(hwndOwner: HWND; {}const{}riid: TIID;
- var ppvOut: Pointer): HResult; virtual; stdcall; abstract;
- function GetAttributesOf(cidl: UINT; var apidl: PItemIDList;
- var rgfInOut: UINT): HResult; virtual; stdcall; abstract;
- function GetUIObjectOf(hwndOwner: HWND; cidl: UINT; var apidl: PItemIDList;
- riid: TIID; var prgfInOut: UINT; var ppvOut: Pointer): HResult; virtual; stdcall; abstract;
- function GetDisplayNameOf(pidl: PItemIDList; uFlags: DWORD;
- var lpName: TStrRet): HResult; virtual; stdcall; abstract;
- function SetNameOf(hwndOwner: HWND; pidl: PItemIDList; lpszName: POLEStr;
- uFlags: DWORD; var ppidlOut: PItemIDList): HResult; virtual; stdcall; abstract;
- end;
- {$endif}
-
- function CreateFolderObject(const ClsID: TGuid): IShellFolder;
- procedure GetFolderItems(Folder: IShellFolder; Items: TListItems);
- function GetSpecialFolderClsID(const FolderName: String): TGuid;
- function GetSpecialFolderLocation(Folder: Cardinal): String;
-
- implementation
-
- uses
- {$ifdef Delphi2}
- OleAuto,
- {$else}
- ComObj, ActiveX,
- {$endif}
- Forms, SysUtils, Registry, IniFiles, Controls;
-
- var
- Malloc: IMalloc;
-
- type
- TShellDetails = record
- fmt: Integer;
- cxChar: Integer;
- str: TStrRet;
- end;
-
- {$ifdef Delphi2}
- const
- IID_IShellDetails: TGUID = (
- D1:$000214EC;D2:$0000;D3:$0000;D4:($C0,$00,$00,$00,$00,$00,$00,$46));
-
- type
- IShellDetails = class(IUnknown)
- function GetDetailsOf(PIdl: PItemIDList; Col: UINT; var Details: TShellDetails): HResult; virtual; stdcall; abstract;
- function ColumnClick(Col: Integer): HResult; virtual; stdcall; abstract;
- end;
- {$else}
- const
- IID_IShellDetails: TGUID = '{000214EC-0000-0000-C000-000000000046}';
-
- type
- IShellDetails = interface(IUnknown)
- ['{000214EC-0000-0000-C000-000000000046}']
- function GetDetailsOf(PIdl: PItemIDList; Col: UINT; var Details: TShellDetails): HResult; stdcall;
- function ColumnClick(Col: Integer): HResult; stdcall;
- end;
- {$endif}
-
- function CreateFolderObject(const ClsID: TGuid): IShellFolder;
- begin
- {$ifdef Delphi2}
- OleCheck(CoCreateInstance(ClsID, nil, CLSCTX_INPROC_SERVER or
- CLSCTX_LOCAL_SERVER, IID_IShellFolder, Result));
- {$else}
- Result := CreateCOMObject(ClsID) as IShellFolder
- {$endif}
- end;
-
- function ControlTextWidth(AControl: TControl; const AString: String): Integer;
- begin
- with TControlCanvas.Create do
- try
- Control := AControl;
- Result := TextWidth(AString)
- finally
- Free
- end;
- end;
-
- function GetFolderItemsDetails(Folder: IShellFolder; Items: TListItems): Boolean;
- var
- Enum: IEnumIDList;
- PIDL: PItemIDList;
- Fetched: {$ifdef Delphi2}ULong{$else}DWord{$endif};
- ShellDetails: IShellDetails;
- ColCount, Loop: Integer;
- Details: TShellDetails;
- DetailStr: String;
- begin
- Result := True;
- //Try and get IShellDetails directly from folder interface
- if Failed(Folder.QueryInterface(IID_IShellDetails, ShellDetails)) then
- //Try and get IShellDetails indirectly from folder interface
- //Folder.CreateViewObject(Application.handle, IID_IShellDetails, Pointer(ShellDetails));
- Folder.CreateViewObject(0, IID_IShellDetails, Pointer(ShellDetails));
- //Exit if shell details interface unavailable
- if ShellDetails = nil then
- begin
- Result := False;
- Exit
- end;
- //Add in relevant column headers
- ColCount := 0;
- while Succeeded(ShellDetails.GetDetailsOf(nil, ColCount, Details)) do
- begin
- with TListView(Items.Owner).Columns.Add do
- begin
- Width := ControlTextWidth(Items.Owner, 'g') * Details.cxChar;
- case Details.str.uType of
- STRRET_WSTR: Caption := WideCharToString(Details.str.pOleStr);
- STRRET_OFFSET: Caption := '';
- STRRET_CSTR: Caption := Details.str.cStr;
- end;
- end;
- Inc(ColCount);
- end;
- //Get enumeration object, just for files - not folders
- OleCheck(Folder.EnumObjects(
- Application.Handle, SHCONTF_NONFOLDERS, Enum));
- //Get 1 item at a time. Not efficient, but still...
- while (Enum.Next(1, PIDL, Fetched) = NOERROR) and (Fetched = 1) do
- begin
- for Loop := 0 to ColCount - 1 do
- begin
- //Ask for the column text
- OleCheck(ShellDetails.GetDetailsOf(PIDL, Loop, Details));
- //It may come back in a number of formats
- case Details.str.uType of
- STRRET_WSTR:
- begin
- DetailStr := WideCharToString(Details.str.pOleStr);
- Malloc.Free(Details.str.pOleStr)
- end;
- STRRET_OFFSET:
- DetailStr := PChar(Cardinal(PIDL) + Details.str.uOffset);
- STRRET_CSTR:
- DetailStr := Details.str.cStr;
- end;
- if Loop = 0 then //Add in either main item text
- Items.Add.Caption := DetailStr
- else //or a subitem (for report style lists)
- Items[Items.Count - 1].SubItems.Add(DetailStr)
- end;
- Malloc.Free(PIDL); //Free item
- end
- end;
-
- procedure GetFolderItemsNoDetails(Folder: IShellFolder; Items: TListItems);
- var
- Enum: IEnumIDList;
- PIDL: PItemIDList;
- Fetched: {$ifdef Delphi2}ULong{$else}DWord{$endif};
- StrRet: TStrRet;
- begin
- with TListView(Items.Owner).Columns.Add do
- begin
- Caption := 'Name';
- Width := 400;
- end;
- //Get enumeration object, just for files - not folders
- OleCheck(Folder.EnumObjects(
- Application.Handle, SHCONTF_NONFOLDERS, Enum));
- //Get 1 item at a time. Not efficient, but still...
- while (Enum.Next(1, PIDL, Fetched) = NOERROR) and (Fetched = 1) do
- begin
- //Ask for the name
- OleCheck(Folder.GetDisplayNameOf(PIDL, SHGDN_FORPARSING, StrRet));
- //It may come back in a number of formats
- case StrRet.uType of
- STRRET_WSTR:
- begin
- Items.Add.Caption := WideCharToString(StrRet.pOleStr);
- Malloc.Free(StrRet.pOleStr)
- end;
- STRRET_OFFSET:
- Items.Add.Caption := PChar(Cardinal(PIDL) + StrRet.uOffset);
- STRRET_CSTR:
- Items.Add.Caption := StrRet.cStr;
- end;
- Malloc.Free(PIDL); //Free item
- end
- end;
-
- procedure GetFolderItems(Folder: IShellFolder; Items: TListItems);
- begin
- TListView(Items.Owner).Columns.Clear;
- Items.Clear;
- Items.BeginUpdate;
- try
- if not GetFolderItemsDetails(Folder, Items) then
- GetFolderItemsNoDetails(Folder, Items)
- finally
- Items.EndUpdate
- end
- end;
-
- function GetSpecialFolderClsID(const FolderName: String): TGuid;
- var
- ClsID: String;
- {$ifdef Delphi2}
- const
- REGSTR_PATH_EXPLORER = 'Software\Microsoft\Windows\CurrentVersion\Explorer';
- REGSTR_PATH_SPECIAL_FOLDERS = REGSTR_PATH_EXPLORER + '\Shell Folders';
- {$endif}
- begin
- with TRegistry.Create do
- try
- //Locate special folders in registry
- if OpenKey(REGSTR_PATH_SPECIAL_FOLDERS, False) then
- //Read requested folder name & read DESKTOP.INI
- with TIniFile.Create(ReadString(FolderName) + '\DESKTOP.INI') do
- try
- //Entry should be marked as CLSID or UICLSID
- ClsID := ReadString('.ShellClassInfo', 'CLSID', '');
- if ClsID = '' then
- ClsID := ReadString('.ShellClassInfo', 'UICLSID', '');
- //Translate from string to real GUID record
- Result := {$ifdef Delphi2}StringToClassID(ClsID){$else}StringToGUID(ClsID){$endif}
- finally
- Free //delete TIniFile
- end;
- finally
- Free //Delete TRegistry
- end;
- end;
-
- function GetSpecialFolderLocation(Folder: Cardinal): String;
- var
- PIDList: PItemIDList;
- Buf: array[0..MAX_PATH] of Char;
- begin
- Result := 'Not available';
- if (SHGetSpecialFolderLocation(
- Application.Handle, Folder, PIDList) = NOERROR) and
- SHGetPathFromIDList(PIDList, Buf) then
- begin
- Result := Buf;
- Malloc.Free(PIDList);
- end
- end;
-
- initialization
- ShGetMalloc(Malloc);
- end.
-